home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Collections: Taifun
/
Taifun 006 (1987-02-15)(Ossowski, Stefan)(DE)(PD).zip
/
Taifun 006 (1987-02-15)(Ossowski, Stefan)(DE)(PD).adf
/
Crystal-Vision
(
.txt
)
< prev
next >
Wrap
AmigaBASIC Source Code
|
1987-03-04
|
10KB
|
368 lines
' Crystal Vision By Jeff White
' Placed In The Public Domain By Merlin's Software
' Subroutine To Load Graphics By Carolyn Scheppner
CLEAR 32000,45000
Main:
DIM bPlane&(5), cTabWork%(32), cTabSave%(32),p(60)
DECLARE FUNCTION xOpen& LIBRARY
DECLARE FUNCTION xRead& LIBRARY
DECLARE FUNCTION xWrite& LIBRARY
DECLARE FUNCTION IoErr& LIBRARY
DECLARE FUNCTION AllocMem&() LIBRARY
DIM g(40,40),h(40,40),i(40,40),j(20,20),k(20,20),l(20,20),m(20,20),n(20,20)
LIBRARY "dos.library"
LIBRARY "exec.library"
LIBRARY "graphics.library"
FOR m = 0 TO 8: READ MM%(m): NEXT m
DATA 85,0,160,1,15500,64,0,0,0
SAY TRANSLATE$("ONE MOMENT PLEASE."),MM%
title:
acbmname$ = "crystal.pic"
loadError$ = ""
GOSUB LoadACBM
IF loadError$ <> "" THEN GOTO Mcleanup
Mcleanup:
GOTO ROUTINE
Mcleanup2:
LIBRARY CLOSE
IF loadError$ <> "" THEN PRINT loadError$
END
LoadACBM:
f$ = acbmname$
fHandle& = 0
mybuf& = 0
foundBMHD = 0
foundCMAP = 0
foundCAMG = 0
foundCCRT = 0
foundABIT = 0
filename$ = f$ + CHR$(0)
fHandle& = xOpen&(SADD(filename$),1005)
IF fHandle& = 0 THEN
loadError$ = "Can't open/find pic file"
GOTO Lcleanup
END IF
ClearPublic& = 65537
mybufsize& = 360
mybuf& = AllocMem&(mybufsize&,ClearPublic&)
IF mybuf& = 0 THEN
loadError$ = "Can't alloc buffer"
GOTO Lcleanup
END IF
inbuf& = mybuf&
cbuf& = mybuf& + 120
ctab& = mybuf& + 240
rLen& = xRead&(fHandle&,inbuf&,12)
tt$ = ""
FOR kk = 8 TO 11
tt% = PEEK(inbuf& + kk)
tt$ = tt$ + CHR$(tt%)
NEXT
IF tt$ <> "ACBM" THEN
loadError$ = "Not an ACBM pic file"
GOTO Lcleanup
END IF
ChunkLoop:
REM - Get Chunk name/length
rLen& = xRead&(fHandle&,inbuf&,8)
icLen& = PEEKL(inbuf& + 4)
tt$ = ""
FOR kk = 0 TO 3
tt% = PEEK(inbuf& + kk)
tt$ = tt$ + CHR$(tt%)
NEXT
IF tt$ = "BMHD" THEN 'BitMap header
foundBMHD = 1
rLen& = xRead&(fHandle&,inbuf&,icLen&)
iWidth% = PEEKW(inbuf&)
iHeight% = PEEKW(inbuf& + 2)
iDepth% = PEEK(inbuf& + 8)
iCompr% = PEEK(inbuf& + 10)
scrWidth% = PEEKW(inbuf& + 16)
scrHeight% = PEEKW(inbuf& + 18)
iRowBytes% = iWidth% /8
scrRowBytes% = scrWidth% / 8
nColors% = 2^(iDepth%)
AvailRam& = FRE(-1)
NeededRam& = ((scrWidth%/8)*scrHeight%*(iDepth%+1))+5000
IF AvailRam& < NeededRam& THEN
loadError$ = "Not enough free ram."
GOTO Lcleanup
END IF
kk = 1
IF scrWidth% > 320 THEN kk = kk + 1
IF scrHeight% > 200 THEN kk = kk + 2
SCREEN 2,scrWidth%,scrHeight%,iDepth%,kk
WINDOW 2,"Crystal Vision",,15,2
SCREEN 3,scrWidth%,scrHeight%,iDepth%,kk
REM - Get addresses of structures
GOSUB GetScrAddrs
REM - Black out screen
CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
ELSEIF tt$ = "CMAP" THEN 'ColorMap
foundCMAP = 1
rLen& = xRead&(fHandle&,cbuf&,icLen&)
REM - Build Color Table
FOR kk = 0 TO nColors% - 1
red% = PEEK(cbuf&+(kk*3))
gre% = PEEK(cbuf&+(kk*3)+1)
blu% = PEEK(cbuf&+(kk*3)+2)
regTemp% = (red%*16)+(gre%)+(blu%/16)
POKEW(ctab&+(2*kk)),regTemp%
NEXT
ELSEIF tt$ = "CAMG" THEN 'Amiga ViewPort Modes
foundCAMG = 1
rLen& = xRead&(fHandle&,inbuf&,icLen&)
camgModes& = PEEKL(inbuf&)
ELSEIF tt$ = "CCRT" THEN 'Graphicraft color cycle info
foundCCRT = 1
rLen& = xRead&(fHandle&,inbuf&,icLen&)
ccrtDir% = PEEKW(inbuf&)
ccrtStart% = PEEK(inbuf& + 2)
ccrtEnd% = PEEK(inbuf& + 3)
ccrtSecs& = PEEKL(inbuf& + 4)
ccrtMics& = PEEKL(inbuf& + 8)
ELSEIF tt$ = "ABIT" THEN 'Contiguous BitMap
foundABIT = 1
plSize& = (scrWidth%/8) * scrHeight%
FOR pp = 0 TO iDepth% -1
rLen& = xRead&(fHandle&,bPlane&(pp),plSize&)
NEXT
ELSE
REM - Reading unknown chunk
FOR kk = 1 TO icLen&
rLen& = xRead&(fHandle&,inbuf&,1)
NEXT
REM - If odd length, read 1 more byte
IF (icLen& OR 1) = icLen& THEN
rLen& = xRead&(fHandle&,inbuf&,1)
END IF
END IF
IF foundBMHD AND foundCMAP AND foundABIT THEN
GOTO GoodLoad
END IF
IF rLen& > 0 THEN GOTO ChunkLoop
IF rLen& < 0 THEN 'Read error
loadError$ = "Read error"
GOTO Lcleanup
END IF
IF (foundBMHD=0) OR (foundABIT=0) OR (foundCMAP=0) THEN
loadError$ = "Needed ILBM chunks not found"
GOTO Lcleanup
END IF
GoodLoad:
loadError$ =""
IF foundCMAP THEN
CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
END IF
Lcleanup:
IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
RETURN
GetScrAddrs:
REM - Get addresses of screen structures
sWindow& = WINDOW(7)
sScreen& = PEEKL(sWindow& + 46)
sViewPort& = sScreen& + 44
sRastPort& = sScreen& + 84
sColorMap& = PEEKL(sViewPort& + 4)
colorTab& = PEEKL(sColorMap& + 4)
sBitMap& = PEEKL(sRastPort& + 4)
scrWidth% = PEEKW(sScreen& + 12)
scrHeight% = PEEKW(sScreen& + 14)
scrDepth% = PEEK(sBitMap& + 5)
nColors% = 2^scrDepth%
FOR kk = 0 TO scrDepth% - 1
bPlane&(kk) = PEEKL(sBitMap&+8+(kk*4))
NEXT
RETURN
ROUTINE:
WINDOW OUTPUT 2
GET (130,59)-(188,127),g
GET (29,59)-(87,127),h
GET (226,59)-(284,127),i
GET (28,5)-(69,53),j
GET (225,5)-(266,53),k
GET (28,131)-(61,173),l
GET (214,131)-(247,173),m
GET (252,131)-(285,173),n
LINE (27,5)-(70,54),12,bf
LINE (223,5)-(266,54),12,bf
LINE (28,131)-(61,173),12,bf
LINE (214,131)-(285,173),12,bf
LINE (27,56)-(90,130),12,bf
LINE (224,56)-(286,130),12,bf
LINE (130,59)-(188,127),29,bf
SCREEN CLOSE 3
GOSUB appear3
SAY TRANSLATE$("are you ready to select a card."),MM%
GOSUB SWITCH
SAY TRANSLATE$("MASTER. HAVE A SPECTAYTOR SELECT A CARD. ANY CARD."),MM%
SAY TRANSLATE$("CLICK ON YES WHEN THEY HAVE FINISHED."),MM%
GOSUB SWITCH
SAY TRANSLATE$("CONSINTRATE ON YOUR CARD."),MM%
GOSUB appear
SAY TRANSLATE$("WOULD YOU LIKE TO TRY AGAIN."),MM%
GOSUB SWITCH
IF MOUSE(4) >90 THEN GOTO FINISHED
SAY TRANSLATE$("MASTER. HAVE A SPECTAYTOR SELECT A CARD."),MM%
SAY TRANSLATE$("CLICK ON YES WHEN THEY HAVE FINISHED."),MM%
GOSUB SWITCH
GOSUB appear1
SAY TRANSLATE$("CARE TO TEST ME ONCE MORE"),MM%
GOSUB SWITCH
IF MOUSE(4) >90 THEN GOTO FINISHED
SAY TRANSLATE$("MASTER. ONE MORE TIME FOR THE NON BELEAVERS."),MM%
SAY TRANSLATE$("CLICK ON YES WHEN THEY HAVE FINISHED."),MM%
GOSUB SWITCH
GOSUB appear2
FINISHED:
PUT (138,65),k,PSET
SAY TRANSLATE$("I HOPE YOU HAVE ENJOYED THIS DEMONSTRATION."),MM%
PUT (138,65),j,PSET
SAY TRANSLATE$(" "),MM%
FOR T= 1 TO 1000: NEXT
PUT (138,65),k,PSET
SAY TRANSLATE$("GOOD BY UNTIL WE MEET AGAIN."),MM%
PUT (138,65),j,PSET
y= 65
FOR T= 1 TO 50
LINE (138,y)-(180,y),29,bf
y= y+1
FOR x= 1 TO 100: NEXT
NEXT
y= 65
FOR T= 1 TO 50
LINE (138,y)-(180,y),29,bf
y= y+1
FOR x= 1 TO 100: NEXT
NEXT
SYSTEM
appear:
FOR T= 1 TO 6000: NEXT
SAY TRANSLATE$(" think harder. i can not get an image."),MM%
FOR T= 1 TO 6000: NEXT
SAY TRANSLATE$(" i have it now. your card was the king of harts."),MM%
a= 0.63
PALETTE 1,a,a,a
PUT(130,59),g,PSET
FOR T= 1 TO 62
a= a+ 0.005
PALETTE 1,a,a,a
NEXT
FOR T= 1 TO 5000: NEXT
FOR T= 1 TO 62
a= a- 0.005
PALETTE 1,a,a,a
NEXT
LINE (130,59)-(188,127),29,bf
RETURN
appear1:
SAY TRANSLATE$("CONSINTRATE ON YOUR CARD."),MM%
FOR T= 1 TO 3000: NEXT
SAY TRANSLATE$("THAT WAS EASY. YOUR CARD WAS THE 8 OF SPAYIDS."),MM%
FOR T= 1 TO 3000: NEXT
a= 0.63
PALETTE 1,a,a,a
PUT(130,59),h,PSET
FOR T= 1 TO 62
a= a+ 0.005
PALETTE 1,a,a,a
NEXT
FOR T= 1 TO 5000: NEXT
FOR T= 1 TO 62
a= a- 0.005
PALETTE 1,a,a,a
NEXT
LINE (130,59)-(188,127),29,bf
RETURN
appear2:
SAY TRANSLATE$("CONSINTRATE ."),MM%
FOR T= 1 TO 5000: NEXT
SAY TRANSLATE$("SO YOU THINK YOU CAN FOOL ZARDOZ."),MM%
FOR T= 1 TO 3000: NEXT
SAY TRANSLATE$("YOUR CARD WAS THE 3 OF DYEMONDS."),MM%
a= 0.63
PALETTE 1,a,a,a
PUT(130,59),i,PSET
FOR T= 1 TO 62
a= a+ 0.005
PALETTE 1,a,a,a
NEXT
FOR T= 1 TO 5000: NEXT
FOR T= 1 TO 62
a= a- 0.005
PALETTE 1,a,a,a
NEXT
LINE (130,59)-(188,127),29,bf
RETURN
appear3:
PUT (138,65),k,PSET
SAY TRANSLATE$("MERLINS SOFTWARE PRESENTS."),MM%
PUT (138,65),j,PSET
SAY TRANSLATE$(" "),MM%
FOR T= 1 TO 1000: NEXT
PUT (138,65),k,PSET
SAY TRANSLATE$("crystal vision."),MM%
PUT (138,65),j,PSET
FOR T= 1 TO 1000: NEXT
PUT (138,65),k,PSET
SAY TRANSLATE$("my name"),MM%
PUT (138,65),j,PSET
FOR T= 1 TO 1000: NEXT
PUT (138,65),k,PSET
SAY TRANSLATE$("is zardoz."),MM%
PUT (138,65),j,PSET
SAY TRANSLATE$(" "),MM%
FOR T= 1 TO 1000: NEXT
PUT (138,65),k,PSET
SAY TRANSLATE$("I will now demonstrate my powers of telepathy."),MM%
PUT (138,65),j,PSET
SAY TRANSLATE$(" "),MM%
FOR T= 1 TO 1000: NEXT
PUT (138,65),k,PSET
SAY TRANSLATE$("lets BEGIN."),MM%
PUT (138,65),j,PSET
y= 65
FOR T= 1 TO 50
LINE (138,y)-(180,y),29,bf
y= y+1
FOR x= 1 TO 100: NEXT
NEXT
RETURN
SWITCH:
a= 0.63
PALETTE 1,a,a,a
PUT(142,68),l,PSET
FOR T= 1 TO 62
a= a+ 0.005
PALETTE 1,a,a,a
NEXT
CHOOSE:
IF MOUSE(0) <> 1 THEN CHOOSE
IF MOUSE(4) <78 THEN GOTO yes
IF MOUSE(4) >90 THEN GOTO no
GOTO CHOOSE
yes:
PUT (142,68),n,PSET
FOR T= 1 TO 3000: NEXT
FOR T= 1 TO 62
a= a- 0.005
PALETTE 1,a,a,a
NEXT
LINE (142,68)-(190,120),29,bf
RETURN
no:
PUT (142,68),m,PSET
FOR T= 1 TO 3000: NEXT
FOR T= 1 TO 62
a= a-0.005
PALETTE 1,a,a,a
NEXT
LINE (142,68)-(190,120),29,bf
RETURN